home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / C / DEBUG.C < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-24  |  48.4 KB  |  1,683 lines
  1. /* DEBUG.C
  2.  ************************************************************************
  3.  *                                    *
  4.  *        PC Scheme/Geneva 4.00 Borland C code            *
  5.  *                                    *
  6.  * (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7.  * (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8.  *                                    *
  9.  *----------------------------------------------------------------------*
  10.  *                                    *
  11.  *            Main Debugger Code                *
  12.  *                                    *
  13.  *----------------------------------------------------------------------*
  14.  *                                    *
  15.  * Created by: John Jensen        Date: 1985            *
  16.  * Revision history:                            *
  17.  * - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18.  *                                    *
  19.  *                    ``In nomine omnipotentii dei''    *
  20.  ************************************************************************/
  21.  
  22. #include    <stdio.h>
  23. #include    <conio.h>
  24. #include    <stdlib.h>
  25. #include    <string.h>
  26. #include    <ctype.h>
  27. #include    "scheme.h"
  28.  
  29. #ifndef BUFSIZE
  30. #define BUFSIZE 160
  31. #endif
  32. #define INTR_OUTPUT if (GETCHready()) {(void) GETCH(); break;}
  33.  
  34. int        check_page(char [], unsigned *, unsigned *, unsigned *);
  35. int        get_hex(char);
  36. unsigned    hex_val(char [], unsigned *);
  37. int        get_int(char);
  38. unsigned    int_val(char [], unsigned *);
  39. int        hex_byte(char [], unsigned *);
  40. long        hex_word(char [], unsigned *);
  41.  
  42. void    dump_scheme( unsigned, unsigned, unsigned, unsigned, void (*)( SCHEMEOBJ, unsigned, unsigned, unsigned ) );
  43. void    dump_list( unsigned, unsigned, unsigned );
  44. int    dump_environment(unsigned, unsigned);
  45. void    dump_hash(void);
  46. void    dump_hex(unsigned, unsigned, unsigned);
  47. void    dump_memory(unsigned, unsigned, unsigned);
  48. void    dump_page_table(void);
  49. void    dump_prop(void);
  50. void    dump_regs(void);
  51. void    dump_stk(void);
  52. void    prt_reg(int);
  53. void    annotate(unsigned, unsigned);
  54.  
  55. unsigned char    get_b(unsigned);
  56. unsigned    get_reg(unsigned);
  57. unsigned    get_w(unsigned);
  58. void        save_regs( unsigned *, int );
  59.  
  60. char    *spchars[SPECIALCHARS] = {
  61.     "\nNEWLINE",    " SPACE",    "\177RUBOUT",    "\fPAGE",
  62.     "\tTAB",    "\bBACKSPACE",    "\rRETURN",    "\033ESCAPE"};
  63.  
  64. #define    NUMREGS    7    /* no instruction has more than that ! */
  65. #define    NOTUSED    0xffff
  66. typedef    enum {        /* Format Codes: */
  67.     NOP,        /* no operands */
  68.     R,        /* reg */
  69.     RR,        /* reg,reg */
  70.     RRR,        /* reg,reg,reg */
  71.  
  72.     C,        /* short offset (signed) */
  73.     B,        /* short offset (unsigned) */
  74.     I,        /* long offset (signed) */
  75.  
  76.     BR,        /* byte (unsigned),reg */
  77.  
  78.     RC,        /* reg,short offset (signed) */
  79.     RB,        /* reg,short offset (unsigned) */
  80.     RI,        /* reg,long offset (signed) */
  81.  
  82.     RBR,        /* reg,byte (unsigned),reg */
  83.     RRC,        /* reg,reg,byte */
  84.     RUR,        /* reg,word (unsigned),reg */
  85.     RRI,        /* reg,reg,word */
  86.  
  87.     RBC,        /* reg,byte (unsigned),byte (signed) */
  88.     RIB,        /* reg,word (signed),byte (unsigned) */
  89.     ICB,        /* word (signed),byte (signed),byte (unsigned) */
  90.  
  91.     R4,        /* reg,reg,reg,reg */
  92.     R5,        /* reg,reg,reg,reg,reg */
  93.     R6,        /* reg,reg,reg,reg,reg,reg */
  94.     R7,        /* reg,reg,reg,reg,reg,reg,reg */
  95.  
  96.     BRV,        /* length, reg, zero or more regs */
  97.     NUMMODES }
  98.     ADDRESSINGMODES;
  99.  
  100. static int      n_ops[NUMMODES] = { 
  101.     0,    1,    2,    3,
  102.     -1,    -1,    -1,
  103.     -1,
  104.     2,    -1,    -1,
  105.     -1,    -1,
  106.     -1,    -1,    -1,
  107.     4,    5,    6,    7,
  108.     -1};
  109.  
  110. static char     format[0x100] = {
  111. /* 000 */    RR,    RB,    RC,    R,    RB,    RBC,    RB,    RB,
  112. /* 008 */    RB,    RB,    RI,/*!*/RR,    RB,    RBC,    RB,    RB,
  113. /* 016 */    RB,    RBR,    RUR,    RRR,    RR,    RR,    RR,    RR,
  114. /* 024 */    R,    R,    B,    RR,    NOP,    BR,    B,    RB,
  115. /* 032 */    C,    I,    RC,    RI,    RC,    RI,    RC,    RI,
  116. /* 040 */    RC,    RI,    RRC,    RRI,    RRC,    RRI,    R,    R,
  117. /* 048 */    ICB,    ICB,    ICB,    ICB,    RB,    RB,    R,    R,
  118. /* 056 */    RR,    RR,    R,    NOP,    RIB,    B,    R,    RR,
  119. /* 064 */    RR,    RR,    RR,    RR,    RR,    RR,    RR,    RR,
  120. /* 072 */    RR,    RR,    RR,    RR,    RR,    RR,    RR,    RRR,
  121. /* 080 */    RR,    RC,    RR,    RR,    RC,    RR,    RC,    RR,
  122. /* 088 */    RR,    R,    R,    R,    RR,    RR,    RR,    RR,
  123. /* 096 */    RR,    RR,    RR,    RR,    RR,    RR,    RR,    RR,
  124. /* 104 */    RR,    RR,    R,    R,    RR,    RR,    RR,    R,
  125. /* 112 */    RR,    RR,    RR,    RR,    RR,    RRR,    R,    RR,
  126. /* 120 */    RR,    RR,    RR,    NOP,    NOP,    RR,    RR,    RR,
  127.  
  128. /* 128 */    R,    R,    R,    R,    R,    R,    R,    R,
  129. /* 136 */    R,    R,    R,    R,    R,    R,    R,    R,
  130. /* 144 */    R,    R,    R,    R,    R,    R,    R,    R,
  131. /* 152 */    R,    R,    R,    R,    R,    R,    NOP,    NOP,
  132. /* 160 */    R,    R,    R6,    NOP,    NOP,    R,    R,    RRR,
  133. /* 168 */    R,    R,    RR,    RRR,    R5,    R,    R,    R,
  134. /* 176 */    RR,    R,    RR,    RR,    RR,    R,    R,    R,
  135. /* 184 */    R,    NOP,    R,    R,    R,    R,    R,    R,
  136. /* 192 */    RR,    RR,    RR,    RR,    R,    R,    R,    RR,
  137. /* 200 */    RRR,    RR,    RR,    R,    R,    R,    R4,    R4,
  138. /* 208 */    R,    RRR,    RR,    R,    R,    RR,    R7,    BRV,
  139. /* 216 */    RR,    R,    R,    RR,    RRR,    B,    B,    RB,
  140. /* 224 */    RB,    R,    RRR,    R,    R,    R,    RR,    RRR,
  141. /* 232 */    BRV,    BRV,    NOP,    NOP,    NOP,    NOP,    NOP,    NOP,
  142. /* 240 */    RR,    RR,    RRR,    R,    R,    R,    R,    NOP,
  143. /* 248 */    NOP,    NOP,    R,    NOP,    NOP,    NOP,    NOP,    NOP};
  144.  
  145. /************************************************************************/
  146. /* "Disassemble" a Scheme Instruction for Error Message *IRRITANT*    */
  147. /*                                    */
  148. /* Note:  This routine works for instructions with only registers for    */
  149. /* operands.  Immediates, offsets, etc., will cause a list to        */
  150. /* be created with only the function name in the first position.    */
  151. /*                                    */
  152. /* The "offset" operand is the absolute displacement of the        */
  153. /* instruction in the page containing the current code block,        */
  154. /* not the displacement relative to the beginning of the code        */
  155. /* block.                                */
  156. /************************************************************************/
  157. void    disassemble(char *function, unsigned offset)
  158. {
  159.     REGPTR        reg_addr[10];    /* register addresses of the instruction's operands */
  160.     unsigned    page;
  161.     int        i;
  162.     int        numoperands;
  163.     int        op;
  164.     REG        fix_reg = FIXNUM(0);
  165.  
  166.     /* determine characteristics of the instruction with which we're dealing */
  167.     page = CORRPAGE(cb_reg.page);
  168.     op = get_byte(page, offset++);
  169.     tmp_reg = nil_reg;
  170.     if ((numoperands = n_ops[format[op]]) > 0)
  171.     {
  172.         /* compute the register address for each operand */
  173.         for (i = 0; i < numoperands; i++)
  174.             reg_addr[i] = regs + get_byte(page, offset++) / sizeof(REG);
  175.         /* if last operand is an immediate operand, phoney up a register for it */
  176.         if (format[op] == RC)
  177.         {
  178.             reg_addr[i - 1] = &fix_reg;
  179.             fix_reg.disp = ((signed)get_byte(page, offset - 1) << 8) >> 8;
  180.         }
  181.         /* cons up argument list */
  182.         for (i = numoperands - 1; i >= 0; i--)
  183.             cons(&tmp_reg, reg_addr[i], &tmp_reg);
  184.     }
  185.     /* create a symbol for the function name and cons on front of argument list */
  186.     intern(&tm2_reg, function, strlen(function));
  187.     cons(&tmp_reg, &tm2_reg, &tmp_reg);
  188. }
  189.  
  190. #ifdef    VMDEBUG                /* cancel module if no debug */
  191.  
  192. static char    *page_type[NUMTYPES] = {"LIST", "FIX", "FLO", "BIG", "SYM",
  193.     "STR",    "ARY",    "CONT",    "CLOS",    "FREE",
  194.     "CODE",    "I86",    "PORT",    "CHAR",    "ENV"};
  195.  
  196. unsigned long    icount[0x100] = { 0, };
  197.  
  198. static char    *opcodes[0x100] = {
  199. /* 000 */    "load",        "ld-const",    "ld-imm",    "ld-nil",    "ld-local",    "ld-lex",    "ld-env",    "ld-global",
  200. /* 008 */    "ld-fluid",    "ld-vec-s",    "ld-vec-l",    "ld-vec-r",    "st-local",    "st-lex",    "st-env",    "st-global",
  201. /* 016 */    "st-fluid",    "st-vec-s",    "st-vec-l",    "st-vec-r",    "set-car!",    "set-cdr!",    "set-ref!",    "Iap-ref!",
  202. /* 024 */    "pop",        "push",        "drop",        "ld-global-r",    "(unused)",    "bind-fl",    "unbind-fl",    "define!",
  203. /* 032 */    "jmp-s",    "jmp-l",    "j-nil-s",    "j-nil-l",    "jnnil-s",    "jnnil-l",    "jatom-s",    "jatom-l",
  204. /* 040 */    "jnatom-s",    "jnatom-l",    "jeq-s",    "jeq-l",    "jneq-s",    "jneq-l",    "deref",    "ref",
  205. /* 048 */    "call",        "call-tr",    "call/cc",    "call/cc-tr",    "call-cl",    "call-cl-tr",    "call/cc-cl",    "call/cc-cl-tr",
  206. /* 056 */    "apply-cl",    "apply-cl-tr",    "execute",    "exit",        "close",    "drop-env",    "mk-hash-env",    "ld-fluid-r",
  207. /* 064 */    "%%car",    "%%cdr",    "caar",        "cadr",        "cdar",        "cddr",        "caaar",    "caadr",
  208. /* 072 */    "cadar",    "caddr",    "cdaar",    "cdadr",    "cddar",    "cdddr",    "cadddr",    "cons",
  209. /* 080 */    "add",        "add-imm",    "sub",        "mul",        "mul-imm",    "div",        "div-imm",    "quotient",
  210. /* 088 */    "remainder",    "%car",        "%cdr",        "random",    "<",        "<=",        "=",        ">",
  211. /* 096 */    ">=",        "!=",        "max",        "min",        "eq?",        "eqv?",        "equal?",    "memq",
  212. /* 104 */    "memv",        "member",    "reverse!",    "reverse",    "assq",        "assv",        "assoc",    "list",
  213. /* 112 */    "append!",    "append",    "delq!",    "delete!",    "get-prop",    "put-prop",    "proplist",    "remprop",
  214. /* 120 */    "list2",    "list-ref",    "list-tail",    "(unused)",    "(unused)",    "bitwise-xor",    "bitwise-and",    "bitwise-or",
  215.  
  216. /* 128 */    "atom?",    "closure?",    "code?",    "continuation?","even?",    "float?",    "fluid-bound?",    "integer?",
  217. /* 136 */    "null?",    "number?",    "odd?",        "pair?",    "port?",    "proc?",    "ref?",        "string?",
  218. /* 144 */    "symbol?",    "vector?",    "zero?",    "negative?",    "positive?",    "abs",        "float",    "minus",
  219. /* 152 */    "floor",    "ceiling",    "truncate",    "round",    "char?",    "env?",        "(unused)",    "(unused)",
  220. /* 160 */    "ascii->char",    "char->ascii",    "%str-str",    "(unused)",    "(unused)",    "length",    "last-pair",    "substr",
  221. /* 168 */    "alloc-vector",    "vector-size",    "vector-fill",    "mk-pack-vector","substr-display","unread-char","%start-timer",    "%stop-timer",
  222. /* 176 */    "open-port",    "close-port",    "prin1",    "princ",    "print",    "newline",    "%push-history","%get-history",
  223. /* 184 */    "print-length",    "clear-history","read-line",    "read-atom",    "read-char",    "%transcript",    "read-char-ready?","fasl",
  224. /* 192 */    "char=",    "char-equal?",    "char<",    "char-less?",    "char-upcase",    "char-downcase","string-length","string-ref",
  225. /* 200 */    "string-set!",    "make-string",    "string-fill!",    "str->sym",    "str->un-sym",    "sym->str",    "find-next-char","find-prev-char",
  226. /* 208 */    "%make-window",    "%reify-port!",    "%reify-port",    "%clear-window","%save-window",    "%restore-window","%str-append","%graphics",
  227. /* 216 */    "%reify",    "mk-env",    "env-parent",    "env-lookup",    "define-env",    "push-env",    "drop-env",    "ld-env",
  228. /* 224 */    "st-env",    "set-glob-env!","%reify!",    "obj-hash",    "obj-unhash",    "%reify-stack",    "%reify-stack!","set-file-position!",
  229. /* 232 */    "%esc",        "%mouse",    "(unused)",    "(unused)",    "(unused)",    "(unused)",    "(unused)",    "(unused)",
  230. /* 240 */    "make-port",    "%port-get-att","%port-set-att!","%read-char",    "%read-line",    "%char-ready?",    "%peek-char",    "%gc2",
  231. /* 248 */    "%halt",    "%gc",        "ptime",    "reset",    "scheme-reset",    "clear-regs",    "(escape)",    "begin-debug"};
  232.  
  233. static unsigned     page, disp, displ;
  234.  
  235. RETVALUE    t_inst(unsigned _page, unsigned *pc, unsigned *retcode, int flags)
  236. {
  237.     unsigned    len = 3, op;
  238.     RETVALUE    stat = PROCEED;
  239.     REG        before[NUMREGS];
  240.     unsigned    reg[NUMREGS];
  241.  
  242.     disp = *pc;
  243.     page = _page;
  244.     displ = flags & T_DISPLAY;
  245.  
  246.     op = get_byte(page, disp);
  247.     if (displ)
  248.         zprintf("\t\t\t\t%3x:%04x  %12s", page, *pc, opcodes[op]);
  249.     
  250.     for( int i = 0; i < NUMREGS; i++ )
  251.         reg[i] = NOTUSED;
  252.  
  253.     switch (format[op]) {
  254.     case NOP:
  255.         if (displ)
  256.             zprintf("\n");
  257.         len = 1;
  258.         break;
  259.  
  260.     case R:                /* one register operand */
  261.         save_regs( reg, 1 );
  262.         fmt_regs(1);
  263.         len = 2;
  264.         break;
  265.  
  266.     case RR:            /* two register operands */
  267.         save_regs( reg, 2 );
  268.         fmt_regs(2);
  269.         break;
  270.  
  271.     case RRR:            /* three register operands */
  272.         save_regs( reg, 3 );
  273.         fmt_regs(3);
  274.         len = 4;
  275.         break;
  276.  
  277.     case R4:            /* four register operands */
  278.         save_regs( reg, 4 );
  279.         fmt_regs(4);
  280.         len = 5;
  281.         break;
  282.  
  283.     case R5:            /* five register operands */
  284.         save_regs( reg, 5 );
  285.         fmt_regs(5);
  286.         len = 6;
  287.         break;
  288.  
  289.     case R6:            /* six register operands */
  290.         save_regs( reg, 6 );
  291.         fmt_regs(6);
  292.         len = 7;
  293.         break;
  294.  
  295.     case R7:            /* seven register operands */
  296.         save_regs( reg, 7 );
  297.         fmt_regs(7);
  298.         len = 8;
  299.         break;
  300.  
  301.     case C:                /* short offset (signed byte) */
  302.         if (displ)
  303.             zprintf("   %d\n", (signed char) get_w(1));
  304.         len = 2;
  305.         break;
  306.  
  307.     case I:                /* long offset (signed word) */
  308.         if (displ)
  309.             zprintf("   %d\n", (signed) get_w(1));
  310.         break;
  311.  
  312.     case B:                /* unsigned short offset (byte) */
  313.         if (displ)
  314.             zprintf("   %d\n", get_b(1));
  315.         len = 2;
  316.         break;
  317.  
  318.     case BR:            /* unsigned short offset (byte) plus register */
  319.         reg[0] = get_reg(2);
  320.         if (displ)
  321.             zprintf("   %d, R%d\n", get_b(1), reg[0]);
  322.         break;
  323.  
  324.     case RC:            /* one register plus short offset (signed) */
  325.         save_regs( reg, 1 );
  326.         if (displ)
  327.             zprintf("   R%d, %d\n", reg[0], (signed char) get_b(2));
  328.         break;
  329.  
  330.     case RB:            /* one register plus short offset (unsigned) */
  331.         save_regs( reg, 1 );
  332.         if (displ)
  333.             zprintf("   R%d, %d\n", reg[0], get_b(2));
  334.         break;
  335.  
  336.     case RI:            /* one register plus long offset (signed) */
  337.         save_regs( reg, 1 );
  338.         if (displ)
  339.             zprintf("   R%d, %d\n", reg[0], (signed) get_w(2));
  340.         len = 4;
  341.         break;
  342.  
  343.     case RBR:            /* register, short offset (unsigned), register */
  344.         save_regs( reg, 1 );
  345.         reg[1] = get_reg(3);
  346.         if (displ)
  347.             zprintf("   R%d, %d, R%d\n", reg[0], get_b(2), reg[1]);
  348.         len = 4;
  349.         break;
  350.  
  351.     case RRC:            /* register, register, short offset (signed), register */
  352.         save_regs( reg, 2 );
  353.         if (displ)
  354.             zprintf("   R%d, R%d, %d\n", reg[0], reg[1], (signed char) get_b(3) );
  355.         len = 4;
  356.         break;
  357.  
  358.     case RRI:            /* register, register, short offset (signed), register */
  359.         save_regs( reg, 2 );
  360.         if (displ)
  361.             zprintf("   R%d, R%d, %d\n", reg[0], reg[1], (signed) get_w(3) );
  362.         len = 4;
  363.         break;
  364.  
  365.     case RUR:            /* register, long offset (unsigned), register */
  366.         save_regs( reg, 1 );
  367.         reg[1] = get_reg(4);
  368.         if (displ)
  369.             zprintf("   R%d, %d, R%d\n", reg[0], get_w(2), reg[1]);
  370.         len = 5;
  371.         break;
  372.  
  373.     case RBC:            /* register, unsigned byte, signed byte */
  374.         save_regs( reg, 1 );
  375.         if (displ)
  376.             zprintf("   R%d, %d, %d\n", reg[0], get_b(2), (signed char) get_b(3));
  377.         len = 4;
  378.         break;
  379.  
  380.     case RIB:            /* register, signed word, unsigned byte */
  381.         save_regs( reg, 1 );
  382.         if (displ)
  383.             zprintf("   R%d, %d, %u\n", reg[0], (signed) get_w(2), get_b(4));
  384.         len = 5;
  385.         break;
  386.  
  387.     case ICB:            /* signed word, signed byte, unsigned byte */
  388.         if (displ)
  389.             zprintf("   %d, %d, %d\n", (signed) get_w(1), (signed char) get_b, get_b(4));
  390.         len = 5;
  391.         break;
  392.  
  393.     case BRV:            /* unsigned length byte, register, zero or more registers */
  394.         len = get_b(1);     /* length byte = #opt. param. = #bytes - 2) */
  395.         disp++;            /* skip length */
  396.         save_regs( reg, len );
  397.         if (displ)
  398.         {
  399.             zprintf(".%d", len );
  400.             for( int i = 0; i < len; i++ )
  401.                 zprintf("%s R%d", i ? "," : "", get_reg(i+1) );
  402.             zprintf("\n");
  403.         }
  404.         len += 2;
  405.         break;
  406.  
  407.     default:
  408.         zprintf("t_inst: Invalid instruction format op=%02x\n", op );
  409.     }
  410.  
  411.     if (flags & T_RUN) {
  412.         if (displ) {
  413.             /* dump the registers prior to execution */
  414.             int    i, j;
  415.  
  416.             for( i = 0; i < NUMREGS; i++ )
  417.             {
  418.                 for( j = 0; j < i; j++ )
  419.                 if( reg[i] == reg[j] )
  420.                     reg[i] = NOTUSED;
  421.                 if( reg[i] != NOTUSED )
  422.                     prt_reg(reg[i]),
  423.                     before[i] = regs[reg[i]];
  424.             }
  425.         }
  426.         /* execute the instruction */
  427.         stat = interp(pc, retcode, 1);
  428.  
  429.         if (displ) {
  430.             /* dump the registers after execution */
  431.             int    i;
  432.             for( i = 0; i < NUMREGS; i++ )
  433.             {
  434.                 if (reg[i] != NOTUSED )
  435.                 if( regs[reg[i]].disp != before[i].disp ||
  436.                     regs[reg[i]].page != before[i].page ) 
  437.                     zprintf("-->"), prt_reg(reg[i]);
  438.             }
  439.         }
  440.     }
  441.     else
  442.         (*pc) += len;
  443.     return    stat;
  444. }
  445.  
  446. /************************************************************************/
  447. /* Format a Series of Register Operands                    */
  448. /************************************************************************/
  449. void    fmt_regs( int n )
  450. {
  451.     if (displ) {
  452.         for( int i = 1; i <= n; i++ )
  453.             zprintf("%s R%d", i == 1 ? "  " : ",", get_reg(i) );
  454.         zprintf("\n");
  455.     }
  456. }
  457.  
  458. /************************************************************************/
  459. /* Save a Series of Register Operands                    */
  460. /************************************************************************/
  461. void    save_regs( unsigned *reg, int n  )
  462. {
  463.     for( int i = 0; i < n && i < NUMREGS; i++ )
  464.         reg[i] = get_reg(i+1);
  465. }
  466.  
  467. /************************************************************************/
  468. /* Return Register Number                        */
  469. /************************************************************************/
  470. unsigned    get_reg(unsigned offset)
  471. {
  472.     return    get_byte(page, disp + offset) >> 2;
  473. }
  474.  
  475. /************************************************************************/
  476. /* Return Word Value                            */
  477. /************************************************************************/
  478. unsigned    get_w(unsigned offset)
  479. {
  480.     return    get_word(page, disp + offset);
  481. }
  482.  
  483. /************************************************************************/
  484. /* Return Byte Value                            */
  485. /************************************************************************/
  486. unsigned char    get_b(unsigned offset)
  487. {
  488.     return    get_byte(page, disp + offset);
  489. }
  490.  
  491. /************************************************************************/
  492. /* TIPC Scheme '84 Interactive Debugger                    */
  493. /*                                    */
  494. /* Purpose:  This utility assists the compiler developer by allowing    */
  495. /* him or her to interactively display and modify the data        */
  496. /* structures of the Scheme Virtual Machine as a program        */
  497. /* executes.                                */
  498. /************************************************************************/
  499. RETVALUE    sdebug( unsigned *retcode )
  500. {
  501.     char        buffer[BUFSIZE];
  502.     unsigned    disp;
  503.     int        i, j, k;
  504.     unsigned    length;
  505.     unsigned    page;
  506.     unsigned    sav_disp;
  507.  
  508.     if (!vm_debug)
  509.     {
  510. reset:
  511.         zprintf("\nAttempting to execute SCHEME-RESET\n"
  512.                "[Returning to top level]\n");
  513.         cb_reg.page = ADJPAGE(SPECCODE);
  514.         cb_reg.disp = 0;
  515.         s_pc = rst_ent - 1;
  516.         goto run_it;
  517.     }
  518.  
  519.     zprintf("\nPC Scheme Virtual Machine Debugger\n");
  520.  
  521.     for(;;)
  522.     {
  523.         zprintf("COMMAND: ");
  524.         i = 0;
  525.         ssetadr(ADJPAGE(IN_PAGE), IN_DISP);
  526.         while ((j = take_ch()) != '\r')
  527.             if (j != '\n')
  528.                 buffer[i++] = j;
  529.         buffer[i] = take_ch();    /* get last zero */
  530.         if( i == 0 )
  531.             continue;
  532.  
  533.         switch (tolower(buffer[0]))
  534.         {
  535.         case 'a':    /* display accounting information */
  536.             accounting();
  537.             break;
  538.  
  539.         case 'd':    /* Dump Memory:  Page:Offset [length] */
  540.             i = tolower(buffer[1]);    /* save second character */
  541.             if (i != 'f')
  542.             {
  543.                 unsigned idx = 1;
  544.                 if (check_page(buffer, &idx, &page, &disp))
  545.                     break;
  546.                 if ((length = hex_val(buffer, &idx)) == 0)
  547.                     length = DEFAULT_LENGTH;
  548.                 length = min(length, psize[page] - disp);
  549.             }
  550.             switch (i)
  551.             {
  552.             case 'g':    /* dump global environment */
  553.                 page = CORRPAGE(gnv_reg.page);
  554.                 disp = gnv_reg.disp;
  555.                 while (page)
  556.                 {
  557.                     INTR_OUTPUT;
  558.                     zprintf("\n\t*** NEW RIB ***\n");
  559.                     sav_disp = disp;
  560.                     disp += 2 * sizeof(POINTER);
  561.                     for (i = 0; i < HT_SIZE; i++, disp += sizeof(POINTER))
  562.                     {
  563.                         INTR_OUTPUT;
  564.                         if ((j = get_byte(page, disp)) != 0)
  565.                         if( dump_environment(j, get_word(page, disp + 1)) )
  566.                         {
  567.                             page = sav_disp = 0;
  568.                             break;
  569.                         }
  570.                     }
  571.                     disp = get_word(page, sav_disp + 4);
  572.                     page = CORRPAGE(get_byte(page, sav_disp + 3));
  573.                 }
  574.                 break;
  575.             case 'f':    /* dump fluid environment */
  576.                 dump_environment(fnv_reg.page, fnv_reg.disp);
  577.                 break;
  578.             case 'h':    /* hexadecimal dump */
  579.                 dump_hex(page, disp, length);
  580.                 break;
  581.             case 'p':  /* dump the property list */
  582.                 dump_prop();            
  583.                 break;
  584.             case 's':    /* dump the runtime stack */
  585.                 dump_stk();
  586.                 break;
  587.             case 'o':
  588.                 dump_hash();
  589.                 break;
  590.             default:    /* regular ole dump of a page */
  591.                 dump_memory(page, disp, length);
  592.             }
  593.             break;
  594.  
  595.         case 'e':    /* Execute this here program */
  596.         {        /* Note: breakpoints are dangerous !
  597.                 They are not relocated properly ! */
  598.             unsigned    idx = 1;
  599.             char        oldopcode;
  600.             if (check_page(buffer, &idx, &page, &disp))
  601.                 break;
  602.             if( page == 0 )
  603.                 goto    run_it;
  604.             oldopcode = get_byte( page, disp );
  605.             put_byte( page, disp, 0xff );    /* write begin-debug */
  606.             if( run(&s_pc, retcode, 0x7fff) == HALT )
  607.                 return    HALT;
  608.             put_byte( page, disp, oldopcode );
  609.             if( CORRPAGE(cb_reg.page) == page && s_pc == disp+1 )
  610.                 s_pc--;        /* back up to real instruction */
  611.             if (!vm_debug)
  612.                 goto reset;
  613.             break;
  614.         }
  615.  
  616.         run_it:
  617.             if (run(&s_pc, retcode, 0x7fff) == HALT)
  618.                 return    HALT;
  619.             else    if (!vm_debug)
  620.                     goto reset;
  621.             break;
  622.  
  623.         case 'g':    /* invoke garbage collector */
  624.         {
  625.             unsigned    after[NUMPAGES], before[NUMPAGES];
  626.             unsigned    idx = 1;
  627.  
  628.             sum_space(before);
  629.             garbage();
  630.             sum_space(after);
  631.             for (i = DEDPAGES; i < NUMPAGES; i++)
  632.             if( before[i] != after[i] )
  633.             {
  634.                 zprintf("Page %3x: ", i );
  635.                 if( after[i] < before[i] )
  636.                     zprintf("%x bytes compacted\n", before[i] - after[i] );
  637.                 else    zprintf("%x bytes recovered\n", after[i] - before[i] );
  638.             }
  639.  
  640.             if( !hex_val(buffer, &idx) )
  641.                 break;
  642.  
  643.             for (i = DEDPAGES, j = 0; i < NUMPAGES; i++)
  644.             if (ptype[i] == FREETYPE)
  645.                 j++;
  646.             gcsquish();    /* go for memory compaction */
  647.             for (i = DEDPAGES, k = 0; i < NUMPAGES; i++)
  648.             if (ptype[i] == FREETYPE)
  649.                 k++;
  650.             zprintf("%x pages reclaimed\n", k - j);
  651.             break;
  652.         }
  653.         case '?':    /* print out commands currently defined */
  654.             zprintf("Valid Debugger Commands:\n"
  655.                 "  A - display accounting information\n"
  656.                 "  DH [page:offset [length]] - dump memory hex\n"
  657.                 "  D  [page:offset [length]] - dump memory formatted\n"
  658.                 "  DF,DG,DS,DP - dump fluids, globals, stack, prop.list\n"
  659.                 "  E [page:offset] - execute program (optional breakpoint)\n"
  660.                 "  G - invoke Garbage collection\n"
  661.                 "  I reg <CR> atom - input atom to register\n"
  662.                 "  IP [n] - set IP to n; if none, decrement IP by 1\n"
  663.                 "  O - display registers as s-expressions\n"
  664.                 "  P - dump page table\n"
  665.                 "  Q [retvalue] - quit (return to DOS)\n"
  666.                 "  R,RE - display registers, do scheme-reset\n"
  667.                 "  S - assembly debug\n"
  668.                 "  T [n] - trace n instructions, 1 if no argument\n"
  669.                 "  U - unassemble the next few instructions\n"
  670.                 "  WB [page:offset data ...] - write bytes\n"
  671.                 "  WW [page:offset data ...] - write words\n"
  672.                 "  X [n] - execute n instructions, infinity if no argument\n"
  673.                 "  ? - help (prints this information)\n");
  674.             break;
  675.  
  676.         case 'i':    /* input atom into register */
  677.             if (tolower(buffer[1]) == 'p')
  678.             {
  679.                 unsigned idx = 2;
  680.                 i = hex_val(buffer, &idx);
  681.                 s_pc = (i > 0 ? i : s_pc - 1);
  682.             } else {
  683.                 unsigned idx = 1;
  684.                 i = int_val(buffer, &idx) % NUM_REGS;
  685.                 sread_atom(regs + i, ADJPAGE(IN_PAGE), IN_DISP);
  686.                 while ( take_ch() != '\r'); /* skip the rest of the line */
  687.                 take_ch(); /* get the last 0 */
  688.             }
  689.             break;
  690.  
  691.         case 'o':    /* print s-expressions pointed by regs */
  692.             {
  693.             int    i;
  694.  
  695.             for (i = 0; i < NUM_REGS; i++)
  696.             if (regs[i].disp != UN_DISP || regs[i].page != ADJPAGE(UN_PAGE))
  697.                 sprint_reg(i, regs[i].page, regs[i].disp);
  698.             }
  699.             break;
  700.  
  701.         case 'p':    /* print page table and page control information */
  702.             dump_page_table();
  703.             break;
  704.  
  705.         case 'q':    /* quit */
  706.             {
  707.                 unsigned idx = 1;
  708.             *retcode = hex_val(buffer, &idx);
  709.             return    HALT;
  710.             }
  711.         case 'r':
  712.             if (tolower(buffer[1]) == 'e')
  713.             {
  714.                 cb_reg.page = ADJPAGE(SPECCODE);
  715.                 cb_reg.disp = 0;
  716.                 s_pc = rst_ent - 1;
  717.             } else
  718.                 dump_regs();    /* dump registers */
  719.             break;
  720.  
  721.         case 's':            /* assembly debug */
  722. asm            int    3
  723.             break;
  724.  
  725.         case 't':    /* trace instruction execution */
  726.             {
  727.             unsigned idx = 1, pc;
  728.             RETVALUE    stat;
  729.  
  730.             if( (length = hex_val(buffer, &idx)) == 0 )
  731.                 length = 1;
  732.  
  733.             while( length-- )
  734.             if ((stat = t_inst(CORRPAGE(cb_reg.page), &s_pc, retcode, T_RUN | T_DISPLAY)) != PROCEED)
  735.                 break;
  736.             if (stat == HALT)
  737.                 return    HALT;
  738.             pc = s_pc;
  739.             t_inst(CORRPAGE(cb_reg.page), &pc, retcode, T_DISPLAY );
  740.             }
  741.             break;
  742.  
  743.         case 'u':
  744.             dump_memory( CORRPAGE(cb_reg.page), s_pc, 32 );
  745.             break;
  746.  
  747.         case 'w':    /* write memory-- determine if byte or word */
  748.             {
  749.                 unsigned idx = 2;
  750.  
  751.             if (check_page(buffer, &idx, &page, &disp))
  752.                 break;
  753.             switch (tolower(buffer[1])) {
  754.             case 'b':    /* write byte */
  755.                 while ((i = hex_byte(buffer, &idx)) >= 0) {
  756.                     zprintf("%3x:%04x  Previous contents: %02x   Replaced by: %02x\n",
  757.                            page, disp,
  758.                        get_byte(page, disp), i);
  759.                     put_byte(page, disp, i);
  760.                     disp++;
  761.                 }
  762.                 break;
  763.  
  764.             case 'w':    /* write word */
  765.                 {
  766.                 long    i;
  767.  
  768.                 while ((i = hex_word(buffer, &idx)) >= 0)
  769.                 {
  770.                     zprintf("%3x:%04x  Previous contents: %04x   Replaced by: %04lx\n",
  771.                            page, disp,
  772.                       get_word(page, disp), i);
  773.                     put_word(page, disp, i);
  774.                     disp += 2;
  775.                 }
  776.                 }
  777.                 break;
  778.  
  779.             default:
  780.                 goto bad_command;
  781.             }
  782.             }
  783.             break;
  784.  
  785.         case 'x':    /* instruction execution */
  786.             {
  787.                 unsigned idx = 1;
  788.                 length = hex_val(buffer, &idx);
  789.             }
  790.             {    /* volatile 'cause of use in case of register crash */
  791.                 RETVALUE stat;
  792.                 volatile unsigned done = (length ? length : 0xffff);
  793.                 volatile unsigned idx = 0;
  794.             do {
  795.                 stat = interp(&s_pc, retcode, done );
  796.                 switch( stat )
  797.                 {
  798.                 case    HALT:
  799.                     return    HALT;
  800.                 case    CLOBBERED:
  801.                     zprintf("\007Clobbered after %lx instructions\n",
  802.                         done - *retcode + ((long) idx) * 0xffff );
  803.                 case    SDEBUG:
  804.                     length = 1; /* quit loop */
  805.                     break;
  806.                 case    PROCEED:
  807.                     break;
  808.                 }
  809.                 idx++;
  810.             } while( !length );
  811.             }
  812.             break;
  813.  
  814.         default:
  815.         bad_command:
  816.             zprintf("? unrecognized command\n");
  817.             break;
  818.         }
  819.     }
  820. }
  821.  
  822. /************************************************************************/
  823. /* extract a decimal value from a string                */
  824. /************************************************************************/
  825. unsigned    int_val(char str[], unsigned *idx)
  826. {
  827.     char        ch;
  828.     unsigned    ret_val = 0;
  829.     int        i;
  830.  
  831.     /* skip over any leading characters in string */
  832.     while (str[*idx] != '\0' && !isdigit(str[*idx]))
  833.         (*idx)++;
  834.  
  835.     /* continue to extract digits until end of string of delimiter */
  836.     while ((ch = str[*idx]) != 0) {
  837.         if ((i = get_int(ch)) >= 0)
  838.             ret_val = (ret_val * 10) + i;
  839.         else
  840.             break;
  841.         (*idx)++;
  842.     }
  843.     return    ret_val;
  844. }
  845.  
  846. /************************************************************************/
  847. /* extract a hexadecimal value from a string                */
  848. /************************************************************************/
  849. unsigned    hex_val(char str[], unsigned *idx)
  850. {
  851.     char        ch;
  852.     unsigned    ret_val = 0;
  853.     int             i;
  854.  
  855.     /* skip over any leading characters in string */
  856.     while (str[*idx] != '\0' && !isxdigit(str[*idx]))
  857.         (*idx)++;
  858.  
  859.     /* continue to extract digits until end of string of delimiter */
  860.     while ((ch = str[*idx]) != 0) {
  861.         if ((i = get_hex(ch)) >= 0)
  862.             ret_val = (ret_val << 4) + i;
  863.         else
  864.             break;
  865.         (*idx)++;
  866.     }
  867.     return    ret_val;
  868. }
  869.  
  870. /************************************************************************/
  871. /* Extract a byte value from a string                    */
  872. /************************************************************************/
  873. int    hex_byte(char str[], unsigned *idx)
  874. {
  875.     int        first_digit, second_digit;
  876.     while (str[*idx] == ' ')
  877.         (*idx)++;    /* skip leading blanks */
  878.     if ((first_digit = get_hex(str[*idx])) < 0)
  879.         return    -1;
  880.     (*idx)++;
  881.     if ((second_digit = get_hex(str[*idx])) < 0)
  882.         return    first_digit;
  883.     (*idx)++;
  884.     return    first_digit * 16 + second_digit;
  885. }
  886.  
  887. /************************************************************************/
  888. /* Extract a word value from a string                    */
  889. /************************************************************************/
  890. long    hex_word(char str[], unsigned *idx)
  891. {
  892.     int        digit, i;
  893.     long        ret_val = -1;
  894.  
  895.     while (str[*idx] == ' ')
  896.         (*idx)++;    /* skip leading blanks */
  897.  
  898.     for (i = 0; i < 4; i++) {
  899.         if (str[*idx] == '\0')
  900.             return    ret_val;
  901.         if ((digit = get_hex(str[*idx])) < 0)
  902.             return    ret_val;
  903.         ret_val = (ret_val == -1 ? digit : (ret_val << 4) | digit);
  904.         (*idx)++;
  905.     }
  906.     return    ret_val;
  907. }
  908.  
  909. /************************************************************************/
  910. /* Test for a hex digit-- if so, return its decimal value        */
  911. /************************************************************************/
  912. int    get_hex(char ch)
  913. {
  914.     ch = toupper(ch);
  915.  
  916.     if( ch >= '0' && ch <= '9')
  917.         return    ch - '0';
  918.     else if( ch >= 'A' && ch <= 'F')
  919.         return    ch + 10 - 'A';
  920.     else    return    -1;
  921. }
  922.  
  923. /************************************************************************/
  924. /* Test for a decimal digit-- if so, return its value            */
  925. /************************************************************************/
  926. int    get_int(char ch)
  927. {
  928.     return    isdigit(ch) ? ch - '0' : -1;
  929. }
  930.  
  931. /************************************************************************/
  932. /* Verify page number, offset values                    */
  933. /*                                    */
  934. /* Purpose:  This routine checks the page number, displacement, and    */
  935. /* length parameters keyed in by the interactive debug user        */
  936. /* to make sure they are within acceptable bounds.            */
  937. /************************************************************************/
  938. int    check_page(char buffer[], unsigned *idx, unsigned *page, unsigned *disp)
  939. {
  940.     int        ret_val = -1;
  941.  
  942.     *page = hex_val(buffer, idx);
  943.     *disp = hex_val(buffer, idx);
  944.  
  945.     /* Verify that page number is valid */
  946.     if (*page == 0xffff || *page >= NUMPAGES) {
  947.         zprintf("Error: Page numbers must be in the range 0 to %x\n",
  948.                NUMPAGES - 1);
  949.     } else {
  950.         if (attrib[*page].FLAGS.nomemory) {
  951.             zprintf("Error: Page 0x%x has not been allocated\n", *page);
  952.         } else {
  953.             if (*disp == 0xffff || *disp >= psize[*page])
  954.                 zprintf("Error: Displacements must be in the range 0x0000 to 0x%04x\n",
  955.                        psize[*page] - 1);
  956.             else
  957.                 ret_val = 0;    /* valid page, displacement, length */
  958.         }
  959.     }
  960.     return    ret_val;
  961. }
  962.  
  963.  
  964. /************************************************************************/
  965. /* Print s-expressive line of register contents to standard output    */
  966. /************************************************************************/
  967. void    sprint_reg(unsigned name, unsigned page, unsigned disp)
  968. {
  969.     ssetadr(ADJPAGE(OUT_PAGE), OUT_DISP);
  970.     zprintf("R%-2d: ", name );
  971.     show = SP_OUTPUT | SP_SEPARE;
  972.     sprint(CORRPAGE(page), disp, ADJPAGE(OUT_PAGE), OUT_DISP);
  973.     zprintf("\n");
  974. }
  975.  
  976. char    *getsegment( int i, char *s )
  977. {
  978.     int    t = getbase(ADJPAGE(i));
  979.     sprintf( s, t == 1 ? "EMMS" : "%04x", t );
  980.     return    s;
  981. }
  982.  
  983. /************************************************************************/
  984. /* Format a dump of the Page Table                    */
  985. /************************************************************************/
  986. void    dump_page_table(void)
  987. {
  988.     unsigned    i;
  989.     unsigned    start, end;    /* starting and ending limits of FREE pages */
  990.     unsigned    space[NUMPAGES];    /* amount of free space in each page */
  991.     char        s[5];
  992.  
  993.     /* determine the amount of free space in each page */
  994.     sum_space(space);
  995.  
  996.     /* Print Page Table Dump Headings */
  997.     zprintf("\nDump of Scheme Memory Management Page Tables\n\n"
  998.         "Page   Page  Base    Next   Link          Free\n"
  999.         " No    Type  Para   Avail   Page   Size   Bytes  Attributes\n"
  1000.         "----   ----  ----   -----   ----   ----   -----  ----------\n");
  1001.     start = end = 0xffff;
  1002.     for (i = 0; i < nextpage; i++)
  1003.     {
  1004.         if( psize[i] == 0 )
  1005.             continue;
  1006.  
  1007.         if( ptype[i] == FREETYPE )
  1008.         {
  1009.             if( start == 0xffff )
  1010.                 start = i;
  1011.             end = i;
  1012.         } else {
  1013.             INTR_OUTPUT;
  1014.             prt_free(&start, &end);
  1015.             zprintf("%4x  %5s   %s   %4x   %4x%c  %4x   %4x   ", i,
  1016.                    page_type[ptype[i] >> 1], getsegment(i,s), nextcell[i],
  1017.                    pagelink[i], (i == pagelist[ptype[i] >> 1] ? '<' : ' '),
  1018.                    psize[i], space[i]);
  1019.             /* print attributes for page */
  1020.             prt_atr(i);
  1021.  
  1022.             /* Flush line to output device */
  1023.             zprintf("\n");
  1024.         }
  1025.     }
  1026.     prt_free(&start, &end);
  1027.  
  1028.     /* Print summary of pages which are not allocated */
  1029.     if (nextpage < NUMPAGES) {
  1030.         if (nextpage == NUMPAGES - 1)
  1031.             zprintf("%4x is not allocated\n", nextpage);
  1032.         else
  1033.             zprintf("%4x-%x are not allocated\n", nextpage, NUMPAGES - 1);
  1034.     }
  1035. }
  1036.  
  1037. /************************************************************************/
  1038. /* Print Page Attributes                        */
  1039. /*                                    */
  1040. /* Purpose:  This routine prints the attributes of a page on the    */
  1041. /* current print line.  Attributes are separated by commas.        */
  1042. /************************************************************************/
  1043. void    prt_atr(unsigned page)
  1044. {
  1045.     unsigned    bits;
  1046.     static char    *things[16] = {"atom", "list", "fixnum", "flonum", "bignum",
  1047.         "symbol", "string", "array", "no memory", "read only",
  1048.         "continuation", "closure", "inline code", "port", "code block", "char"};
  1049.     char        *comma_needed = "";
  1050.     int        i = 0;
  1051.  
  1052.     bits = attrib[page].word;
  1053.     while (bits) {
  1054.         if (bits & 0x8000) {
  1055.             zprintf("%s%s", comma_needed, things[i]);
  1056.             comma_needed = ",";
  1057.         }
  1058.         i++;
  1059.         bits = (bits << 1);
  1060.     }
  1061. }
  1062.  
  1063. /************************************************************************/
  1064. /* Print Free (unused) Pages of Memory                    */
  1065. /*                                    */
  1066. /* Purpose:  Given a range of unused pages of memory, this routine    */
  1067. /* formats a message to indicate the presence of said pages.        */
  1068. /************************************************************************/
  1069. void    prt_free(unsigned *start, unsigned *end)
  1070. {
  1071.     if( *start != 0xffff )
  1072.     {
  1073.         if( *start == *end )
  1074.             zprintf("Page %x is allocated, but unused\n", *start );
  1075.         else
  1076.             zprintf("Pages %x-%x are allocated, but unused\n", *start, *end );
  1077.         *start = *end = 0xffff;
  1078.     }
  1079. }
  1080.  
  1081. /************************************************************************
  1082.  * Output a scheme object (used by dump_scheme)                *
  1083.  ************************************************************************/
  1084. void    printstring( char far *s, int len )
  1085. {
  1086.     zprintf("\t\"");
  1087.  
  1088.     for( int i = 0; i < len; i++ )
  1089.         zprintf("%c%s", s[i] >= 32 && s[i] < 127 ? s[i] : '.',
  1090.         (i & 0x3f) == 0x3f && i < len-1 ? "\n\t" : "");
  1091.     zprintf("\"\n");
  1092. }
  1093.  
  1094. void    output_flo( SCHEMEOBJ o, unsigned, unsigned, unsigned )
  1095. {
  1096.     zprintf("FLONUM [%le]\n", o->flonum.data );
  1097. }
  1098.  
  1099. void    output_str( SCHEMEOBJ o, unsigned, unsigned, unsigned )
  1100. {
  1101.     int    len = o->string.len - (o->string.buffer - (char far *) o);
  1102.     if( len < 0 )
  1103.         len += 6;
  1104.  
  1105.     zprintf("STRING.%04x [length %d]\n", o->string.len, len );
  1106.     printstring( o->string.buffer, len );
  1107. }
  1108.  
  1109. void    output_sym( SCHEMEOBJ o, unsigned, unsigned, unsigned )
  1110. {
  1111.     int    len = o->symbol.len - (o->symbol.buffer - (char far *) o);
  1112.     if( len < 0 )
  1113.         len += 6;
  1114.  
  1115.     zprintf("SYMBOL.%04x [length %d, link %02x:%04x, hash %02x]\n", o->symbol.len, len,
  1116.         CORRPAGE(o->symbol.link.page), o->symbol.link.disp, o->symbol.hash );
  1117.     printstring( o->symbol.buffer, len );
  1118. }
  1119.  
  1120. void    output_code( SCHEMEOBJ o, unsigned page, unsigned start, unsigned end )
  1121. {
  1122.     unsigned    entry = (int) o + o->codeblock.entry.disp;
  1123.     unsigned    last = (int) o + o->codeblock.len;
  1124.  
  1125.     zprintf("CODE.%04x [begins at %x]\n", o->codeblock.len, entry );
  1126.  
  1127.     for( int i = 0; (int) &o->codeblock.constants[i] < entry; i++ )
  1128.     if( (int) &o->codeblock.constants[i] >= start &&
  1129.         (int) &o->codeblock.constants[i] < end )
  1130.     {
  1131.         INTR_OUTPUT;
  1132.         zprintf("\t%d:\t", i );
  1133.         annotate( CORRPAGE(o->codeblock.constants[i].page),
  1134.             o->codeblock.constants[i].disp );
  1135.     }
  1136.  
  1137.     while( entry < end && entry < last )
  1138.     {
  1139.         INTR_OUTPUT;
  1140.         t_inst( page, &entry, NULL, T_DISPLAY * (entry >= start) );
  1141.     }
  1142. }
  1143.  
  1144. void    output_i86( SCHEMEOBJ o, unsigned page, unsigned start, unsigned end )
  1145. {
  1146.     zprintf("INLINE.%04x\n", o->i86block.len );
  1147.  
  1148.     dump_hex( page, start, end );
  1149. }
  1150.  
  1151. void    output_all( SCHEMEOBJ o, unsigned, unsigned start, unsigned end )
  1152. {
  1153.     int    i, next;
  1154.  
  1155.     zprintf("%s.%04x\n", page_type[o->vector.type >> 1], o->vector.len );
  1156.  
  1157.     if( end > (int) o + o->vector.len )
  1158.         end = (int) o + o->vector.len;
  1159.  
  1160.     for( i = 0; (int) &(o->vector.data[i]) < end; i = next )
  1161.     if( (int) &(o->vector.data[i]) >= start )
  1162.     {
  1163.         INTR_OUTPUT;
  1164.         /* see if following array entries are same as the current one */
  1165.         for( next = i+1; (int) &(o->vector.data[next]) < end; next++ )
  1166.         if( o->vector.data[i].page != o->vector.data[next].page ||
  1167.             o->vector.data[i].disp != o->vector.data[next].disp )
  1168.             break;
  1169.         if( next == i+1 )
  1170.             zprintf("#%d:\t", i );
  1171.         else    zprintf("#%d-%d:\t", i, next );
  1172.  
  1173.         annotate( CORRPAGE(o->vector.data[i].page), o->vector.data[i].disp );
  1174.     }
  1175. }
  1176.  
  1177. void    output_port( SCHEMEOBJ o, unsigned, unsigned, unsigned )
  1178. {
  1179.     zprintf("PORT.%04x [In:", o->port.len );
  1180.     switch( o->port.flags & READ_MODE )
  1181.     {
  1182.     case READ_EXCLUSIVE:
  1183.         zprintf("exclusive"); break;
  1184.     case READ_SHARED:
  1185.         zprintf("shared"); break;
  1186.     case READ_PROTECTED:
  1187.         zprintf("protected"); break;
  1188.     case READ_CLOSED:
  1189.         zprintf("closed"); break;
  1190.     }
  1191.     zprintf(" Out:");
  1192.     switch( o->port.flags & WRITE_MODE )
  1193.     {
  1194.     case WRITE_EXCLUSIVE:
  1195.         zprintf("exclusive "); break;
  1196.     case WRITE_SHARED:
  1197.         zprintf("shared "); break;
  1198.     case WRITE_PROTECTED:
  1199.         zprintf("protected "); break;
  1200.     case WRITE_CLOSED:
  1201.         zprintf("closed "); break;
  1202.     }
  1203.     switch( o->port.flags & PORT_TYPE )
  1204.     {
  1205.     case TYPE_FILE:
  1206.         zprintf("File "); break;
  1207.     case TYPE_STRING:
  1208.         zprintf("String "); break;
  1209.     case TYPE_SOFTWARE:
  1210.         zprintf("Software "); break;
  1211.     case TYPE_WINDOW:
  1212.         zprintf("Window ");
  1213.         zprintf( (o->port.flags & PORT_WRAP) ? "Wrap " : "Clip ");
  1214.         if( o->port.flags & PORT_TRANSCRIPT ) zprintf("Transcript ");
  1215.     }
  1216.     if( (o->port.flags & PORT_TYPE) != TYPE_WINDOW )
  1217.         zprintf( (o->port.flags & PORT_BINARY) ? "Binary " : "Ascii ");
  1218.     if( o->port.flags & PORT_LOCKED )
  1219.         zprintf( "Locked ");
  1220.     zprintf( (o->port.flags & PORT_FLUSHED) ? "Flushed]\n" : "\b]\n");
  1221.  
  1222.     zprintf("\tSource at %2x:%04x\t", o->port.ptr.page, o->port.ptr.disp);
  1223.     show = SP_OUTPUT | SP_SEPARE;
  1224.     sprint(CORRPAGE(o->port.ptr.page), o->port.ptr.disp, ADJPAGE(OUT_PAGE), OUT_DISP);
  1225.     zprintf("\nCurrent position is line %d, column %d\n", 
  1226.             o->port.curline, o->port.curcol);
  1227.  
  1228.     switch( o->port.flags & PORT_TYPE )
  1229.     {
  1230.     case TYPE_WINDOW:
  1231.         zprintf("\tWindow area: upper-left (%d,%d) size (%d,%d)\n",
  1232.             o->port.ulline, o->port.ulcol,
  1233.             o->port.nlines, o->port.ncols );
  1234.         zprintf("\tBorder attributes are %04x, Text attributes %04x\n", o->port.border, o->port.text );
  1235.         break;
  1236.     case TYPE_FILE:
  1237.         zprintf("\tFile handle %x, Buffer base offset %x\n",
  1238.             o->port.handle, o->port.chunk * BUFFSIZE );
  1239.     }
  1240.     zprintf("\tActive buffer:\n");
  1241.     printstring( o->port.buffer + o->port.bufpos,
  1242.         o->port.bufend - o->port.bufpos );
  1243. }
  1244.  
  1245. void    output_big( SCHEMEOBJ o, unsigned, unsigned, unsigned )
  1246. {
  1247.     int    num = o->bignum.data.len/2 - (o->bignum.data.data - (unsigned far *) o);
  1248.  
  1249.     zprintf("BIGNUM.%04x %s\n\t", o->bignum.data.len, o->bignum.data.sign & 1 ? "Negative" : "Positive");
  1250.     for( int i = 0; i < num; i++ )
  1251.         zprintf("%04x%s", o->bignum.data.data[num-i-1], (i & 0xf) == 0xf && i < num-1 ? "\n\t" : "");
  1252.     zprintf("\n");
  1253. }
  1254.  
  1255. /************************************************************************/
  1256. /* Produce a Formatted Dump of an Area of Scheme's Address Space    */
  1257. /************************************************************************/
  1258. void    dump_memory( unsigned page, unsigned disp, unsigned length )
  1259. {
  1260.     char    *description[NUMTYPES] =
  1261.         {"List Cells", "Fixnums", "Flonums",
  1262.         "Bignums", "Symbols", "Strings",
  1263.         "Arrays", "Continuation Cells",
  1264.         "Closures", "Nothing (unused)",
  1265.         "Code", "Inline Code", "Ports",
  1266.         "Characters", "Environments"};
  1267.  
  1268.     if (ptype[page] < NUMTYPES*2 && ptype[page] != FREETYPE) {
  1269.         zprintf("Page %x (attributes ", page ); prt_atr(page);
  1270.         zprintf(") contains %s\n", description[ptype[page] >> 1] );
  1271.  
  1272.         switch( ptype[page] )
  1273.         {
  1274.         case LISTTYPE:
  1275.             dump_list( page, disp, disp+length );
  1276.             break;
  1277.         case SYMTYPE:
  1278.             dump_scheme( page, disp, disp+length, 0, output_sym );
  1279.             break;
  1280.         case STRTYPE:
  1281.             dump_scheme( page, disp, disp+length, 0, output_str );
  1282.             break;
  1283.         case CODETYPE:
  1284.             dump_scheme( page, disp, disp+length, 0, output_code );
  1285.             break;
  1286.         case I86TYPE:
  1287.             dump_scheme( page, disp, disp+length, 0, output_i86 );
  1288.             break;
  1289.         case VECTTYPE:
  1290.         case CLOSTYPE:
  1291.         case CONTTYPE:
  1292.         case ENVTYPE:
  1293.             dump_scheme( page, disp, disp+length, 0, output_all );
  1294.             break;
  1295.         case FLOTYPE:
  1296.             dump_scheme( page, disp, disp+length, sizeof(FLONUM), output_flo );
  1297.             break;
  1298.         case PORTTYPE:
  1299.             dump_scheme( page, disp, disp+length, 0, output_port );
  1300.             break;
  1301.         case BIGTYPE:
  1302.             dump_scheme( page, disp, disp+length, 0, output_big );
  1303.             break;
  1304.         default:
  1305.             zprintf("Error: Invalid page type 0x%x\n", ptype[page] );
  1306.         }
  1307.     } else    zprintf("Error: Invalid page type: 0x%x\n", ptype[page] );
  1308. }
  1309.  
  1310. /************************************************************************/
  1311. /* Produce a Hex Dump of a Page of Scheme's Memory            */
  1312. /************************************************************************/
  1313. void    dump_hex( unsigned page, unsigned disp, unsigned length )
  1314. {
  1315.     for( unsigned start = disp & 0xfff0; start <= disp + length; start++ )
  1316.     {
  1317.         INTR_OUTPUT;
  1318.         if( (start & 0xf) == 0 )
  1319.             zprintf("\n%2x:%04x  ", page, start );
  1320.         if( start >= disp )
  1321.             zprintf("%02x ", get_byte(page, start) );
  1322.         else    zprintf("   ");
  1323.     }
  1324.     zprintf("\n");
  1325. }
  1326.  
  1327. /************************************************************************/
  1328. /* Produce Formatted Dump of a Page Containing List Cells        */
  1329. /************************************************************************/
  1330. void    dump_list( unsigned page, unsigned disp, unsigned end )
  1331. {
  1332.     LIST far *l = &( scheme2c( page, 0 )->list );
  1333.     for( int count = 0; (int) (l+1) <= psize[page]; l++ )
  1334.     {
  1335.         if( l->car.page == 0xff )
  1336.         {
  1337.             count++;
  1338.             continue;
  1339.         }
  1340.         if( (int) (l+1) >= disp && (int) l < end )
  1341.         {
  1342.             INTR_OUTPUT;
  1343.  
  1344.             zprintf("%3x:%04x  ( ", page, (int) l );
  1345.             if( l->car.page )
  1346.                 zprintf("%2x:%04x . ", CORRPAGE(l->car.page), l->car.disp );
  1347.             else    zprintf("NIL . ");
  1348.             if( l->cdr.page )
  1349.                 zprintf("%2x:%04x )\n", CORRPAGE(l->cdr.page), l->cdr.disp );
  1350.             else    zprintf("NIL )\n");
  1351.         }
  1352.     }
  1353.     zprintf("%x unused cells\n", count );
  1354. }
  1355.  
  1356. /************************************************************************/
  1357. /* Produce Formatted Dump of a Page Containing Scheme Objects        */
  1358. /************************************************************************/
  1359. void    dump_scheme( unsigned page, unsigned start, unsigned end, unsigned size,
  1360.     void (*proc)( SCHEMEOBJ, unsigned, unsigned, unsigned ) )
  1361. {
  1362.     int    len, next;
  1363.  
  1364.     for( next = 0; next <= psize[page] - BLK_OVHD; next += len )
  1365.     {
  1366.         SCHEMEOBJ    o = scheme2c(page,next);
  1367.  
  1368.         len = size ? size : o->_.len;
  1369.         if( len < 0 )
  1370.             len = 6;
  1371.  
  1372.         if( next+len > start && next < end )
  1373.         if( o->_.type != 0xff && (o->_.type & 0x3f) != FREETYPE )
  1374.         {
  1375.             zprintf("%3x:%04x  ", page, next );
  1376.             (*proc)( scheme2c( page, next ), page, start, end );
  1377.         }
  1378.     }
  1379. }
  1380.  
  1381. /************************************************************************/
  1382. /* Dump the runtime stack                        */
  1383. /************************************************************************/
  1384. void    dump_stk(void)
  1385. {
  1386.     STACKFRAME    *fp;
  1387.     POINTER        *tos;
  1388.  
  1389.     prt_reg(-4);            /* print the value of prev_reg and the stack base */
  1390.     zprintf("BASE\t%04x\n", base );
  1391.  
  1392.     fp = (STACKFRAME *) (((char *) s_stack) + frameptr);
  1393.     tos = (POINTER *) (((char *) s_stack) + topofstack);
  1394.     while( tos > s_stack )
  1395.     {
  1396.         while( tos >= fp->data )
  1397.         {
  1398.             INTR_OUTPUT;
  1399.             zprintf("@%d:\t", tos - fp->data );
  1400.             annotate( CORRPAGE(tos->page), tos->disp );
  1401.             tos--;
  1402.         }
  1403.         zprintf("%4x: FRAME [cb=%x:%04x, ret=%04x, heap=%x:%04x slink=%04x, clos=%x:%04x]\n",
  1404.             base + &fp->codeblock - s_stack,
  1405.             CORRPAGE(fp->codeblock.page), fp->codeblock.disp,    fp->ret.disp,
  1406.             CORRPAGE(fp->heap.page), fp->heap.disp,
  1407.             fp->slink.disp,
  1408.             CORRPAGE(fp->closure.page), fp->closure.disp );
  1409.  
  1410.         tos -= sizeof(STACKFRAME) / sizeof(POINTER) - 1;
  1411.         fp = (STACKFRAME *) (((char *) s_stack) + fp->dlink.disp - base);
  1412.     }
  1413. }
  1414.  
  1415. /************************************************************************/
  1416. /* Dump the VM's Registers                        */
  1417. /************************************************************************/
  1418. void    dump_regs(void)
  1419. {
  1420.     int        i;
  1421.     unsigned    pc = s_pc;
  1422.  
  1423.     /* Print the Contents of the general purpose registers */
  1424.     for (i = 0; i < NUM_REGS; i++)
  1425.         if (regs[i].page != ADJPAGE(UN_PAGE) || regs[i].disp != UN_DISP)
  1426.             prt_reg(i);
  1427.  
  1428.     prt_reg(-1);        /* print fnv */
  1429.     prt_reg(-3);        /* print gnv */
  1430.     prt_reg(-2);        /* print cb  */
  1431.     if (tmp_reg.page & 1)
  1432.         zprintf("odd tmp_page\n");
  1433.     zprintf("tmp_reg ");
  1434.     annotate(CORRPAGE(tmp_reg.page), tmp_reg.disp);
  1435.     t_inst( CORRPAGE(cb_reg.page), &pc, NULL, T_DISPLAY );
  1436. }
  1437.  
  1438. void    prt_reg( int reg )
  1439. {
  1440.     REG    r;
  1441.  
  1442.     /* print the register name and contents */
  1443.     switch( reg )
  1444.     {
  1445.     case -1:
  1446.         zprintf("FNV\t");
  1447.         r = fnv_reg;
  1448.         break;
  1449.     case -2:
  1450.         zprintf("CB\t");
  1451.         r = cb_reg;
  1452.         break;
  1453.     case -3:
  1454.         zprintf("GNV\t");
  1455.         r = gnv_reg;
  1456.         break;
  1457.     case -4:
  1458.         zprintf("PREV\t");
  1459.         r = prev_reg;
  1460.         break;
  1461.     default:
  1462.         zprintf("R%-2d\t", reg );
  1463.         r = regs[reg];
  1464.     }
  1465.  
  1466.     annotate(CORRPAGE(r.page), r.disp);
  1467. }
  1468.  
  1469. void    commentstr( char sep, char far *buffer, int len )
  1470. {
  1471.     if( len < 0 )
  1472.         len += 6;
  1473.     if( len > 30 )
  1474.         len = 30;
  1475.  
  1476.     zprintf(" %c", sep );
  1477.     while( len-- )
  1478.         zprintf("%c", *buffer++ );
  1479.     zprintf("%c\n", sep );
  1480. }
  1481.  
  1482. void    annotate( unsigned page, unsigned disp )
  1483. {
  1484.     SCHEMEOBJ    o;
  1485.  
  1486.     zprintf("%2x:%04x\t%s", page, disp, page_type[CORRPAGE(ptype[page])] );
  1487.     o = scheme2c(page,disp);
  1488.  
  1489.     /* for values, show the value the register points to */
  1490.     switch( ptype[page] )
  1491.     {
  1492.     case SYMTYPE:
  1493.         commentstr('|', o->symbol.buffer, o->symbol.len - (o->symbol.buffer - (char far *) o) );
  1494.         break;
  1495.     case STRTYPE:
  1496.         commentstr('"', o->string.buffer, o->string.len - (o->string.buffer - (char far *) o) );
  1497.         break;
  1498.     case FIXTYPE:
  1499.         zprintf(" %d \n", disp );
  1500.         break;
  1501.     case FLOTYPE:
  1502.         zprintf(" %le\n", o->flonum.data );
  1503.         break;
  1504.     case CHARTYPE:
  1505.         for( int i = 0; i < SPECIALCHARS; i++ )
  1506.         {
  1507.             if( disp == *spchars[i] )
  1508.             {
  1509.                 zprintf(" #\\%s\n", spchars[i]+1 );
  1510.                 return;
  1511.             }
  1512.         }
  1513.         if( disp == 0 )        /* C++ bug: a '0' would end the display */
  1514.             disp = ' ';
  1515.  
  1516.         zprintf(" #\\%c\n", disp );
  1517.         break;
  1518.     case LISTTYPE:
  1519.         if( page == 0 )
  1520.             zprintf(" nil");
  1521.     default:
  1522.         zprintf("\n");
  1523.     }
  1524. }
  1525.  
  1526. /************************************************************************/
  1527. /* Dump Environment                            */
  1528. /************************************************************************/
  1529. int    dump_environment(unsigned page, unsigned disp)
  1530. {
  1531.     REG        search, pair, sym;
  1532.  
  1533.     for( search.page = page, search.disp = disp; search.page; take_cdr(&search) )
  1534.     {
  1535.         char    *symbol;
  1536.  
  1537.         if( GETCHready() )
  1538.         {
  1539.             (void) GETCH();
  1540.             return    1;    /* interrupted */
  1541.         }
  1542.  
  1543.         /* fetch pointer to symbol/value pair */
  1544.         pair = search;
  1545.         take_car(&pair);
  1546.  
  1547.         /* fetch pointer to symbol */
  1548.         sym = pair;
  1549.         take_car(&sym);
  1550.  
  1551.         symbol = symbol_name( CORRPAGE(sym.page), sym.disp );
  1552.         zprintf("%25s", symbol );
  1553.         rlsstr(symbol);
  1554.  
  1555.         /* display the value currently bound to the symbol */
  1556.         take_cdr( &pair );
  1557.         annotate( CORRPAGE(pair.page), pair.disp );
  1558.         ssetadr( ADJPAGE(OUT_PAGE), OUT_DISP );
  1559.         show = SP_OUTPUT | SP_SEPARE;
  1560.         sprint( CORRPAGE(pair.page), pair.disp, ADJPAGE(OUT_PAGE), OUT_DISP );
  1561.  
  1562.         zprintf("\n");
  1563.     }
  1564.     return    0;            /* not interrupted */
  1565. }
  1566.  
  1567. /************************************************************************/
  1568. /*            Dump Contents of Property List            */
  1569. /************************************************************************/
  1570. void    dump_prop(void)
  1571. {
  1572.     REG        ent, prop, temp, sym, val;
  1573.     int        hash_value;    /* current hash key value */
  1574.     char        *symbol;     /* a symbol's print name */
  1575.  
  1576.     for (hash_value = 0; hash_value < HT_SIZE; hash_value++)
  1577.     {
  1578.         ent.page = prop_page[hash_value];
  1579.         ent.disp = prop_disp[hash_value];
  1580.         while (ent.page)
  1581.         {
  1582.             temp = ent;
  1583.             take_car(&temp);
  1584.             sym = temp;
  1585.             take_car(&sym);
  1586.             symbol = symbol_name(CORRPAGE(sym.page),sym.disp);
  1587.             zprintf("\nProperty List for |%s|\n", symbol);
  1588.             rlsstr(symbol);
  1589.  
  1590.             take_cdr(&temp);
  1591.             while(temp.page)
  1592.             {
  1593.                 prop = temp;
  1594.                 take_car(&prop);
  1595.                 zprintf("\tproperty: ");
  1596.                 annotate(CORRPAGE(prop.page), prop.disp);
  1597.                 take_cdr(&temp);
  1598.                 val = temp;
  1599.                 take_car(&val);
  1600.                 zprintf("\tvalue: ");
  1601.                 annotate(CORRPAGE(val.page), val.disp);
  1602.                 take_cdr(&temp);
  1603.             }
  1604.             take_cdr(&ent);
  1605.         }
  1606.     }
  1607. }
  1608.  
  1609. /************************************************************************/
  1610. /*            Dump Contents of Hash Table                */
  1611. /************************************************************************/
  1612. extern    POINTER    obj_hlist;
  1613.  
  1614. void    dump_hash(void)
  1615. {
  1616.     REG    r = REG( obj_hlist );
  1617.  
  1618.     while( r.page )
  1619.     {
  1620.         REG    s = r;
  1621.         take_car( &s );
  1622.         zprintf("\t[%d]\t", reg2c(&s)->list.cdr.disp );
  1623.         take_car( &s );
  1624.         annotate( CORRPAGE(s.page), s.disp );
  1625.         take_cdr( &r );
  1626.     }
  1627. }
  1628.  
  1629. #endif
  1630.  
  1631. #ifdef    VMDEBUG
  1632. typedef    struct {
  1633.         long    val;
  1634.         char    *name;
  1635. }    SORTELEM;
  1636.  
  1637. int    sortfunc( const void *a, const void *b )
  1638. {
  1639.     unsigned long    A = ((SORTELEM *) a)->val, B = ((SORTELEM *) b)->val;
  1640.     if( A > B )
  1641.         return    -1;
  1642.     else    return    A < B;
  1643. }
  1644. #endif
  1645.  
  1646. /************************************************************************/
  1647. /* Display Accounting Information                    */
  1648. /************************************************************************/
  1649. void    accounting(void)
  1650. {
  1651.     extern int    gc_count;    /* garbage collector invocation count */
  1652.     extern long    stk_in, stk_out;/* bytes transfered to/from the stack */
  1653. #ifdef    VMDEBUG
  1654.     int        i;
  1655.     SORTELEM    sorted[0x100];
  1656. #endif
  1657.  
  1658.     zprintf("\nGarbage collector invoked %d times\n", gc_count);
  1659.  
  1660.     zprintf("%9ld bytes transferred from stack to heap\n"
  1661.         "%9ld bytes transferred from heap to stack\n", stk_out, stk_in );
  1662.  
  1663. #ifdef    VMDEBUG
  1664.     for( i = 0; i < 0x100; i++ )
  1665.         sorted[i].val = icount[i], sorted[i].name = opcodes[i];
  1666.  
  1667.     qsort( sorted, 0x100, sizeof(sorted[0]), sortfunc );
  1668.     for( i = 0; i < 0x100 && sorted[i].val; i++ )
  1669.     {
  1670.         zprintf("%15s:%-9ld", sorted[i].name, sorted[i].val );
  1671.         if( i % 3 == 3-1 )
  1672.             zprintf("\n");
  1673.         if( i % 30 == 30-1 )
  1674.         {
  1675.             zprintf("[ \\nq]\r");
  1676.             if( (GETCH() | ('a' - 'A')) == 'q')
  1677.                 break;
  1678.         }
  1679.     }
  1680.     zprintf("\n");
  1681. #endif
  1682. }
  1683.